Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE21/TIPTRIX/LISTING4.PAS

Pascal/Delphi Source File | 1997-04-16 | 5.9 KB | 198 lines

procedure SetHeadings;
var
   slstHotKeys, slstHotKeysSave: TStringList;

   procedure SetTab(pageIndex: integer; header: string);
   begin
      { hot keys that can't be used are <slstHotKeysSave> = main menu,
        notebook tabs, toolbar, popup
        this list must be added to for each each successive page }
      slstHotKeys.Assign(slstHotKeysSave);
      GetHotkeysInWinControl(TTabPages(nbk.Pages.Objects[pageIndex]),
                             slstHotKeys, nil);
      SetAcceleratorKey(slstHotKeys, header);
      nbk.TabCaption[pageIndex] := header;
      slstHotKeys.Clear;
   end;
begin
   slstHotKeys := TStringList.Create;
   slstHotKeysSave := TStringList.Create;
   try
      { pass nil as confident that form does not contain duplicates }
      GetHotKeysInMainMenu(form1.mnuMain, slstHotkeysSave, nil);
      GetHotKeysInNbkTabs(nbk, slstHotKeysSave, nil);
      GetHotKeysInShortCuts(pop, slstHotKeysSave, nil);

      { tab names could be obtained at run-time from some misc source }
      SetHeading(1, 'First');
      SetHeading(2, 'Second');
      SetHeading(3, 'Third');
      SetHeading(4, 'Fourth');
      SetHeading(5, 'Fifth');
   finally
      slstHotKeys.Free;
      slstHotKeysSave.Free;
   end;
end;

procedure GetHotKeysInWinControl(ctrl: TWinControl; slstHotkeys,
slstDuplicates: TStringList);
   procedure ChkValidAndAdd(ctrl: TControl);
   var
      hotKey: string;
   begin
      if HasNamedProperty(ctrl, 'Caption') then begin
         { can use anything to typecast as long as it has a caption property }
         hotKey := GetHotKey(TLabel(ctrl).Caption, False);
         AddHotKey(slstHotkeys, slstDuplicates, hotKey);
      end;
   end;

   procedure CycleControls(ctrl: TWinControl);
   var
      i: integer;
   begin
      { use recursion to check for hotkeys on nested TWinControls }
      if ctrl.ControlCount > 0 then
         for i := 0 to ctrl.ControlCount - 1 do begin
            if ctrl.Controls[i] is TWinControl then
               CycleControls(TWinControl(ctrl.Controls[i]));
            ChkValidAndAdd(ctrl.Controls[i]);
         end;
   end;
begin
   CycleControls(ctrl);
end;

procedure AddHotKey(slstHotkeys, slstDuplicates: TStringList; hotKey: string);
begin
   if hotkey <> '' then
     { returns -1 if check not in lst, otherwise returns index }
     if slstHotKeys.IndexOf(hotKey) = -1 then
        slstHotKeys.Add(hotkey)
     else
        if Assigned(slstDuplicates) then
           slstDuplicates.Add(hotKey);
end;

procedure SetAcceleratorKey(slstHotKeys: TStringList; var toSet: string);
var
   j: integer;
   inList, found : boolean;
   ch : string;
begin
   j := 1;
   found := false;
   while not found do begin
      ch := UpperCase( toSet[j] );
      inList := (slstHotKeys.IndexOf(ch) <> -1);

      if (not inList) and (ch <> #32) then begin
         slstHotKeys.Add(ch);
         toSet := Copy( toSet, 1, j-1 ) + '&' + Copy( toSet, j, Length(toSet) );
         found := true;
      end else begin
         inc(j);
         found := (j > Length(toSet));
      end
   end;
end;

function HasNamedProperty(AComponent: TComponent; const propertyName: string): boolean;
var
   propInfo: PPropInfo;
begin
   propInfo := GetPropInfo(AComponent.ClassInfo, propertyName);
   Result := (propInfo <> nil);
end;

procedure GetHotKeysInNbkTabs(ctrl: TWinControl; slstHotkeys, slstDuplicates: TStringList);
var
   i: integer;
   str : TStrings;
   hotKey: string;
begin
   { setup for 2 notebooks }
   if ctrl is TTabbedNotebook then
      str := (ctrl as TTabbedNotebook).Pages
   else if ctrl is TcsNotebook then
      { Classic notebook }
      str := (ctrl as TCsNotebook).Pages
   else
      Exit;

   { add hotkeys on notebook tabs }
   for i := 0 to str.Count - 1 do begin
      hotKey := GetHotKey(str.Strings[i], False);
      AddHotKey(slstHotkeys, slstDuplicates, hotKey);
   end;
end;

procedure GetHotkeysInMainMenu(mnu: TMainMenu; slstHotkeys, slstDuplicates: TStringList);
var
   i: integer;
   hotKey: string;
begin
   for i := 0 to mnu.Items.Count - 1 do begin
      hotKey := GetHotKey(mnu.Items[i].Caption, True);
      AddHotKey(slstHotkeys, slstDuplicates, hotKey);
   end;
end;

procedure GetHotKeysInShortCuts(mnu: TMenu; slstHotkeys, slstDuplicates: TStringList);
{ use TMenu arguement so can pass TMainMenu and TPopupMenu }
   procedure CycleMenu(itm: TMenuItem);
   var
      i: integer;
      hotKey: string;
      function GetHotKeyInShortCut(strShortCut: string): string;
      { only will conflict with hotkey if shortcut in Alt+? format }
      begin
         Result := '';
         if Copy(strShortCut, 1, 3) = 'Alt' then
            Result := Copy(strShortCut, 5, 1);
      end;
   begin
      { use recursion to check for hotkeys in nested TMenuItems }
      if itm.Count > 0 then
         for i := 0 to itm.Count - 1 do begin
            CycleMenu(itm.Items[i]);
            if itm[i].ShortCut <> 0 then begin
               hotKey := GetHotKeyInShortCut(ShortCutToText(itm[i].ShortCut));
               AddHotKey(slstHotkeys, slstDuplicates, hotKey);
            end;
         end;
   end;
begin
   CycleMenu(mnu.Items);
end;

function GetHotKey(str: string; msg: boolean): string;
var
   i: integer;
   length: byte absolute str;
   nextChar: string;
begin
   i := 1;
   nextChar := Copy(str, i, 1);
   while ((nextChar <> '&') and (i <= length)) do begin
      Inc(i);
      nextChar := Copy(str, i, 1);
   end;

   if (i = length) then begin
      { nextChar could be & or not }
      if msg then
         { self check - should never go in here (for TMenuItems) }
         MsgError(Format('%s has no hotkey', [str]));
      Result := '';
   end else
      Result :=  Copy(str, i + 1, 1);
end;

{ Tom Corcoran, Unitime Systems
  s-mail:    3101 Iris Avenue, Suite 240, Boulder,
             Colorado 80301-1900, USA
  e-mail:    [e-mail] OR
             [e-mail]  }